#lang racket


(require "../base/main.rkt"
         "../ast/main.rkt")

(provide
 ; points
 point
 
 ; lines
 arc
 elliptical-arc
 ellipse
 line
 line-closed
 nurbs-curve
 rectangle
 spline
 
 ; surfaces
 annulus
 ngon
 nurbs-surface
 star
 surface
 
 ; solids 
 box
 cone
 cone-frustrum
 cylinder
 pyramid
 sphere
 
 ; generic shapes
 circle
 circle-surface
 
 ; transformations 
 extrude
 intersect
 join
 loft
 loft-closed
 move
 offset
 rotate
 scale
 subtract
 sweep
 thicken
 union 
 
 ; lang
 align 
 
 on
 on-left
 on-right
 on-front
 on-back
 on-top
 on-bottom)


; exception

(define-struct (constructor-exn exn:fail:contract) ())

(define (raise-constructor-exn msg)
  (raise (make-constructor-exn msg (current-continuation-marks))))

(define (assert-type fn-sym type-fn n-arg args)
  (unless (type-fn (list-ref args n-arg))
    (apply raise-type-error fn-sym (symbol->string (object-name type-fn)) n-arg args)))

(define (assert-types fn-sym type-fns args)
  (for-each
   (λ (type-fn i)
     (assert-type fn-sym type-fn i args))
   type-fns
   (: (length type-fns))))


; utils

(define (rotate-normal normal-p shape)
  (rotate uz normal-p shape))

(define (move-and-rotate-normal base-p normal-p shape)
  (move base-p
        (rotate-normal normal-p shape)))

(define (move-and-rotate-axis base-p top-p shape)
  (let ((axis (sub-c top-p base-p)))
    (move base-p
          (rotate uz axis shape))))


; predicates

(define (angle? a)
  (number? a))

(define (distance? d)
  (and (number? d) (positive? d)))

(define (nonnegative-number? r)
  (and (number? r) (not (negative? r))))

(define (nonnegative-integer? r)
  (and (integer? r) (not (negative? r))))

(define (coord-list? lst)
  (and (list? lst) (every coord? lst)))


; points

(define (point-coord-msg c)
  (format "Point: parameter (c) must be a coord, given ~A" c))

(define point
  (case-lambda
    ((c)
     (unless (coord? c)
       (raise-constructor-exn (point-coord-msg c)))
     (point-node c))
    ((x y z)
     (point (xyz x y z)))))


; lines

; arc

(define (arc-impl angle radius)
  (assert-types 'arc-impl (list number? nonnegative-number?) (list angle radius))
  (cond ((= radius 0) (point u0))
        ((= angle 0) (point (x radius)))
        (else
         (let ((angle (coterminal angle)))
           (if (= angle 0)
               (circle radius)
               (make-arc-node angle radius))))))

(define arc
  (case-lambda
    ((r angle)
     (arc-impl r angle))
    ((r begin-angle end-angle)
     (rotate
      begin-angle
      (arc r (- end-angle begin-angle))))
    ((c r begin-angle end-angle)
     (move
      c
      (rotate
       begin-angle
       (arc r (- end-angle begin-angle)))))))

; /arc


; elliptical-arc

(define (elliptical-arc-impl x-radius y-radius angle)
  (assert-types 'elliptical-arc-impl (list number? nonnegative-number? nonnegative-number?) (list x-radius y-radius angle))
  (cond ((= x-radius y-radius) (arc x-radius angle))
        ((= x-radius 0) (line u0 (y y-radius))) ; edit: depends on the angle
        ((= y-radius 0) (line u0 (x x-radius))) ; edit: depends on the angle
        ((= angle 0) (point (x x-radius)))
        (else
         (let ((angle (coterminal angle)))
           (if (= angle 0)
               (ellipse x-radius y-radius)
               (make-elliptical-arc-node angle x-radius y-radius))))))

(define elliptical-arc
  (case-lambda
    ((r angle)
     (elliptical-arc-impl (xyz-x r) (xyz-y r) angle))
    ((c r angle)
     (move
      c
      (elliptical-arc angle r)))
    ((c r begin-angle end-angle)
     (move
      c
      (rotate
       begin-angle
       (elliptical-arc (- end-angle begin-angle) r))))))

; /elliptical-arc


; ellipse

(define (ellipse-impl x-radius y-radius)
  (assert-types 'ellipse-impl (list nonnegative-number? nonnegative-number?) (list x-radius y-radius))
  (cond ((= x-radius y-radius) (circle x-radius))
        ((= x-radius 0) (line u0 (y y-radius)))
        ((= y-radius 0) (line u0 (x x-radius)))
        (else
         (make-ellipse-node x-radius y-radius))))

(define ellipse
  (case-lambda
    ((r)
     (ellipse-impl (xyz-x r) (xyz-y r)))
    ((c r)
     (move
      c
      (ellipse r)))))


; /ellipse


; line & line-closed

(define (line-impl closed? cs)
  (assert-types 'line-impl (list boolean? coord-list?) (list closed? cs))
  (make-line-node closed? cs))

; edit: eq-c: what is the threshold?
(define line
  (case-lambda
    ((cs)
     (if (eq-c (first cs) (last cs))
         (line-impl #t (butlast cs))
         (line-impl #f cs)))
    ((c1 c2 . cs)
     (line (list* c1 c2 cs)))))

; edit: eq-c: what is the threshold?
(define line-closed
  (case-lambda
    ((cs)
     (cond ((eq-c (first cs) (last cs))
            (displayln "Warning: Line: parameter (cs): first and last coords must not be identical; last coord will be dropped")
            (line-impl #t (butlast cs)))
           (else
            (line-impl #t cs))))
    ((c1 c2 . cs)
     (line-closed (list* c1 c2 cs)))))

; /line & line-closed


(define (nurbs-curve controls knots)
  (make-nurbs-curve-node controls knots))


; rectangle

(define (rectangle-impl width length)
  (assert-types 'rectangle-impl (list nonnegative-number? nonnegative-number?) (list width length))
  (cond ;((= width length) (square-impl width)) ; edit: infinite loop between rectangle and square
        ((= width 0) (line u0 (y length)))
        ((= length 0) (line u0 (x width)))
        (else
         (make-rectangle-node width length))))

(define (rectangle-wl w l)
  (rectangle-impl w l))

(define (rectangle-cc c1 c2)
  (let ((c (sub-c c1 c2)))
    (move
     (midcoord c1 c2)
     (rectangle (abs (xyz-x c)) (abs (xyz-y c))))))

(define rectangle
  (case-lambda
    ((w/c l/c)
     (if (and (number? w/c) (number? l/c))
         (rectangle-wl w/c l/c)
         (rectangle-cc w/c l/c)))
    ((c w l)
     (move c (rectangle w l)))))

; /rectangle


; spline

(define (spline-impl closed? cs type)
  (assert-types 'spline-impl (list boolean? coord-list? spline-type?) (list closed? cs type))
  (make-spline-node closed? cs type))

; edit: eq-c: what is the threshold?
(define spline
  (case-lambda
    ((cs)
     (if (eq-c (first cs) (last cs))
         (spline-impl #t (butlast cs) (auto-spline-type))
         (spline-impl #f cs (auto-spline-type))))
    ((c1 c2 . cs)
     (spline (list* c1 c2 cs)))))

; edit: eq-c: what is the threshold?
(define spline-closed
  (case-lambda
    ((cs)
     (cond ((eq-c (first cs) (last cs))
            (displayln "Warning: Spline: parameter (cs): first and last coords must not be identical; last coord will be dropped")
            (spline-impl #t (butlast cs) (auto-spline-type)))
           (else
            (spline-impl #t cs (auto-spline-type)))))
    ((c1 c2 . cs)
     (spline-closed (list* c1 c2 cs)))))

; edit: eq-c: what is the threshold?
(define (spline-tan cs begin-tangent end-tangent)
  (if (eq-c (first cs) (last cs))
      (spline-impl #t (butlast cs) (tangent-spline-type begin-tangent end-tangent))
      (spline-impl #f cs (tangent-spline-type begin-tangent end-tangent))))

; edit: eq-c: what is the threshold?
(define (spline-closed-tan cs begin-tangent end-tangent)
  (cond ((eq-c (first cs) (last cs))
         (displayln "Warning: Spline closed tan: parameter (cs): first and last coords must not be identical; last coord will be dropped")
         (spline-impl #t (butlast cs) (tangent-spline-type begin-tangent end-tangent)))
        (else
         (spline-impl #t cs (tangent-spline-type begin-tangent end-tangent)))))

; /spline


;(define (square-impl side)
;  (assert-types 'square-impl (list nonnegative-number?) (list side))
;  (if (= side 0)
;      (point u0)
;      (rectangle side side)))


; surfaces

; annulus

(define (annulus-impl begin-radius end-radius)
  (assert-types 'annulus-impl (list nonnegative-number? nonnegative-number?) (list begin-radius end-radius))
  (cond ((= begin-radius end-radius) (circle begin-radius))
        ((= begin-radius 0) (circle-surface end-radius))
        ; ((= end-radius 0) ; edit: what does this mean?
        (else
         (make-donut-node begin-radius end-radius))))

(define annulus
  (case-lambda
    ((begin-radius end-radius)
     (annulus-impl begin-radius end-radius))
    ((c begin-radius end-radius)
     (move c (annulus begin-radius end-radius)))))

; /annulus


; mesh

(define (mesh cs-lst)
  (error 'mesh "Not implemented"))


; ngon

(define (ngon-impl sides radius)
  (assert-types 'ngon-impl (list nonnegative-integer? nonnegative-number?) (list sides radius))
  (cond ((= radius 0) (point u0))
        ((= sides 0) (point u0))
        ;((= sides 1) (line (x width))) ; edit: a line... but how?
        ;((= sides 2) ; edit what is this?
        ;((= sides +inf.0) (circle radius)) ; edit: necessary?
        (else
         (make-ngon-node radius sides))))

(define ngon
  (case-lambda
    ((sides c)
     (rotate (pol-phi c) (ngon-impl sides (pol-rho c))))
    ((sides c1 c2)
     (move c1 (rotate (pol-phi c2) (ngon-impl sides (pol-rho c2)))))))

; /ngon


(define (nurbs-surface controls u-knots v-knots)
  (make-nurbs-surface-node controls u-knots v-knots))


; star

(define (star-impl sides stride radius)
  (assert-types
   'star-impl
   (list nonnegative-integer? nonnegative-integer? nonnegative-number?)
   (list sides stride radius))
  (cond ((= radius 0) (point u0))
        ((= sides 0) (point u0))
        ; edit: other cases (see ngon)
        (else
         (make-star-node radius sides stride))))

(define star
  (case-lambda
    ((sides stride c)
     (rotate (pol-phi c) (star-impl sides stride (pol-rho c))))
    ((sides stride c1 c2)
     (move c1 (rotate (pol-phi c2) (star-impl sides stride (pol-rho c2)))))))


; surface

(define (surface-impl shapes)
  (make-surface-node shapes))

(define surface
  (case-lambda
    ((closed-curve)
     (surface-impl closed-curve))
    ((s1 s2)
     (surface-impl (list s1 s2)))
    ((s1 s2 s3)
     (surface-impl (list s1 s2 s3)))
    ((s1 s2 s3 s4)
     (surface-impl (list s1 s2 s3 s4)))
    ((ps)
     (apply surface ps))))

; /surface


; solids


; box

(define (box-impl width length height)
  (assert-types
   'box-impl
   (list nonnegative-number? nonnegative-number? nonnegative-number?)
   (list width length height))
  (cond ((= width length height 0) (point u0))
        ((= width length 0) (line u0 (z height)))
        ((= width height 0) (line u0 (y length)))
        ((= length height 0) (line u0 (x width)))
        ; ((= width 0) (rectangle (line u0 (y length)) (line u0 (z height))) ; edit: not possible (yet?)
        ; ((= length 0) (rectangle (line u0 (x width)) (line u0 (z height))) ; edit: not possible (yet?)
        ; ((= height 0) (rectangle (line u0 (x width)) (line u0 (y length))) ; edit: not possible (yet?)
        (else
         (make-box-node width length height))))

(define box
  (case-lambda
    ((c1 c2)
     (let ((c (sub-c c1 c2)))
       (move
        (midcoord c1 c2)
        (box (abs (xyz-x c)) (abs (xyz-y c)) (abs (xyz-z c))))))
    ((w l h)
     (box-impl w l h))
    ((c w l h)
     (move c (box w l h)))))

; edit: box-centered?

; /box


; cone

(define (cone-impl r h)
  (make-cone-node r h))

(define (cone-crh c r h)
  (move c (cone r h)))

(define (cone-crc c1 r c2)
  (move-and-rotate-axis c1 c2 (cone r (distance c1 c2))))

(define cone
  (case-lambda
    ((r h)
     (cone-impl r h))
    ((c r h/c)
     (if (number? h/c)
         (cone-crh c r h/c)
         (cone-crc c r h/c)))))

; /cone


; cone-frustrum

(define (cone-frustrum-impl r h top-r)
  (make-cone-frustrum-node r top-r h))

(define (cone-frustrum-crhr c r h top-r)
  (move c (cone-frustrum r h top-r)))

(define (cone-frustrum-crcr c1 r c2 top-r)
  (move-and-rotate-axis
   c1
   c2
   (cone-frustrum r top-r (distance c1 c2))))

(define cone-frustrum
  (case-lambda
    ((r h top-r)
     (cone-frustrum-impl r h top-r))
    ((c r h/c top-r)
     (if (number? h/c)
         (cone-frustrum-crhr c r h/c top-r)
         (cone-frustrum-crcr c r h/c top-r)))))

; /cone-frustrum


; cylinder

(define (cylinder-impl radius height)
  (make-cylinder-node radius height))

(define (cylinder-crh c r h)
  (move c (cylinder r h)))

(define (cylinder-crc c1 r c2)
  (move-and-rotate-axis
   c1
   c2
   (cylinder r (distance c1 c2))))

(define cylinder
  (case-lambda
    ((r h)
     (cylinder-impl r h))
    ((c r h/c)
     (if (number? h/c)
         (cylinder-crh c r h/c)
         (cylinder-crc c r h/c)))))

; /cylinder


;(define (elliptical-cone x-radius y-radius height))
;(define (gengon width sides fillet-width height))
;(define (mesh vertices faces))
;(define (paraboloid radius height))

;(define (platonic-solids width sides))


; pyramid

(define (pyramid-impl sides width height)
  (make-pyramid-node width sides height))

(define (pyramid-scwh sides c w h)
  (move c (pyramid sides w h)))

(define (pyramid-scwc sides c1 w c2)
  (move-and-rotate-axis
   c1
   c2
   (pyramid sides w (distance c1 c2))))

(define pyramid
  (case-lambda
    ((sides w h)
     (pyramid-impl sides w h))
    ((sides c w h/c)
     (if (number? h/c)
         (pyramid-scwh sides c w h/c)
         (pyramid-scwc sides c w h/c)))))

; /pyramid


; sphere

(define (sphere-impl radius)
  (make-sphere-node radius))

(define sphere
  (case-lambda
    ((r)
     (sphere-impl r))
    ((c r)
     (move c (sphere r)))))

; /sphere


;(define (spindle radius height))
;(define (superellipsoid width length height))
;(define (torus base-radius section-radius))
;(define (truncated-icosahedron width))
;(define (wedge width height))


; generic shapes

; circle & circle-surface

(define (circle-impl type radius)
  (assert-types 'circle-impl (list nonnegative-number?) (list radius))
  (if (= radius 0)
      (point u0)
      (make-circle-node type radius)))

(define circle
  (case-lambda
    ((r)
     (circle-impl (line-primitive-type) r))
    ((c r)
     (move c (circle r)))))

(define circle-surface
  (case-lambda
    ((r)
     (circle-impl (surface-primitive-type) r))
    ((c r)
     (move c (circle-surface r)))))

; /circle & circle-surface


; transformations

(define (extrude length shape)
  (make-extrude-node length shape))

;(define (guide-loft guide shapes))


; intersect

(define (intersect-impl shape1 shape2)
  (make-intersect-node shape1 shape2))

(define (intersect-list l)
  (reduce (λ (s ss) (intersect-impl ss s)) l))

(define intersect
  (case-lambda
    ((shape1 shape2 . shapes)
     (intersect-list (cons shape1 (cons shape2 shapes))))
    ((shapes)
     (intersect-list shapes))))

; /intersect


;(define (lattice shape))


; join

(define (join-impl shapes)
  (make-join-node shapes))

(define join
  (case-lambda
    ((shape1 shape2 . shapes)
     (join-impl (cons shape1 (cons shape2 shapes))))
    ((shapes)
     (join-impl shapes))))

; /join


; loft

(define (loft-closed?-msg closed?)
  (format "Loft: first parameter (closed?) must be a boolean, given ~A" closed?))

(define (loft-shapes-msg shapes)
  (format "Loft: second parameter (shapes) must be a list of at least two shapes, given ~A" shapes))

(define (loft-impl closed? shapes)
  (unless (boolean? closed?)
    (raise-constructor-exn (loft-closed?-msg closed?)))
  (unless (and (list? shapes) (andmap node? shapes) (> (length shapes) 1))
    (raise-constructor-exn (loft-shapes-msg shapes)))
  (make-loft-node closed? shapes))

(define loft
  (case-lambda
    ((shapes)
     (loft-impl #f shapes))
    ((shape1 shape2 . shapes)
     (loft-impl #f (list* shape1 shape2 shapes))))) 

(define loft-closed
  (case-lambda
    ((shapes)
     (loft-impl #t shapes))
    ((shape1 shape2 . shapes)
     (loft-impl #t (list* shape1 shape2 shapes)))))

; /loft


;(define (mirror plane shape))


; move

(define (move-c-msg position)
  (format "Move: first parameter (c) must be a coord, given ~A" position))

(define (move-shape-msg shape)
  (format "Move: second parameter (shape) must be a shape, given ~A" shape))

(define (move c shape)
  (unless (coord? c)
    (raise-constructor-exn (move-c-msg c)))
  (unless (node? shape)
    (raise-constructor-exn (move-shape-msg shape)))
  (make-move-node c shape))

; /move


(define (offset distance shape)
  (make-offset-node distance shape))

;(define (path-loft path shapes))
;(define (revolve axis shape))


; rotate

(define (rotate-impl angle normal shape)
  (make-rotate-node angle normal shape))

(define (rotate-an a n shape)
  (rotate-impl a n shape))

(define (rotate-cc c1 c2 shape)
  (let ((n (if (< (p//p c1 c2) 0)
               (collinear-pxp c1)
               (cross-c c1 c2))))
    (rotate (p<\p c1 c2) n shape)))

(define rotate
  (case-lambda
    ((a/c n/c shape)
     (if (number? a/c)
         (rotate-an a/c n/c shape)
         (rotate-cc a/c n/c shape)))))

(define (rotate-x n shape)
  (rotate n ux shape))

(define (rotate-y n shape)
  (rotate n uy shape))

(define (rotate-z n shape)
  (rotate n uz shape))

; /rotate


; scale

(define (scale-c-msg size)
  (format "Scale: first parameter (c) must be a coord, given ~A" size))

(define (scale-shape-msg shape)
  (format "Scale: second parameter (shape) must be a shape, given ~A" shape))

(define (scale c shape)
  (unless (coord? c)
    (raise-constructor-exn (scale-c-msg c)))
  (unless (node? shape)
    (raise-constructor-exn (scale-shape-msg shape)))
  (make-scale-node c shape))

; /scale


;(define (slice plane shape))


; subtract

(define (subtract-shape1-msg shape)
  (format "Subtract: first parameter (shape1) must be a shape, given ~A" shape))

(define (subtract-shape2-msg shape)
  (format "Subtract: second parameter (shape2) must be a shape, given ~A" shape))

(define (subtract-impl shape1 shape2)
  (unless (node? shape1)
    (raise-constructor-exn (subtract-shape1-msg shape1)))
  (unless (node? shape2)
    (raise-constructor-exn (subtract-shape2-msg shape2)))
  (make-subtract-node shape1 shape2))

(define (subtract-list l)
  (reduce (λ (s ss) (subtract-impl ss s)) l))

(define subtract
  (case-lambda
    ((shape arg)
     (if (list? arg)
         (subtract-list (cons shape arg))
         (subtract-impl shape arg)))
    ((shape1 shape2 . shapes)
     (subtract shape1 (cons shape2 shapes)))
    ((shapes)
     (apply subtract shapes))))

; /subtract


(define (sweep path shape)
  (make-sweep-node path shape))


; thicken

(define (thicken-distance-msg distance)
  (format "Thicken: first parameter (distance) must be a number, given ~A" distance))

(define (thicken distance shape)
  (unless (number? distance)
    (raise-constructor-exn (thicken-distance-msg distance)))
  (make-thicken-node distance shape))

; /thicken


; union

(define (union-shapes-msg shapes)
  (format "Union: parameter (shapes) must be a list of shapes, given ~A" shapes))

(define (union-impl shape1 shape2)
  (make-union-node shape1 shape2))

(define (union-list shapes)
  (unless (and (list? shapes) (> (length shapes) 1) (every node? shapes))
    (raise-constructor-exn (union-shapes-msg shapes)))
  (reduce (λ (s ss) (union-impl ss s)) shapes))

(define union
  (case-lambda
    ((shape1 shape2 . shapes)
     (union-list (cons shape1 (cons shape2 shapes))))
    ((shapes)
     (union-list shapes))))

; /union


; lang


; align

(define (align-type-msg type)
  (format "Align: first parameter (type) must be a symbol or a list of symbols, given ~A" type))

(define (align-shape-msg shape)
  (format "Align: second parameter (shape) must be a shape, given ~A" shape))

(define (align-impl type shape)
  (unless (node? shape)
    (raise-constructor-exn (align-shape-msg shape)))
  (make-align-node (make-align-type type) shape))

(define (align type shape)
  (if (symbol? type)
      (align-impl type shape)
      (foldr (λ (t s) (align-impl t s)) (align-impl (first type) shape) type)))


; /align


; on

(define (on-type-msg type)
  (format "On: first parameter (type) must be a symbol, given ~A" type))

(define (on-shapes-msg shapes)
  (format "On: second parameter (shapes) must be a list of at least two shapes, given ~A" shapes))

(define (on-impl type shapes)
  (unless (symbol? type)
    (raise-constructor-exn (on-type-msg type)))
  (unless (and (list? shapes) (every node? shapes))
    (raise-constructor-exn (on-shapes-msg shapes)))
  (make-on-node (make-on-type type) shapes))

(define on
  (case-lambda
    ((type shapes)
     (on-impl type shapes))
    ((type shape1 shape2 . shapes)
     (on-impl type (list* shape1 shape2 shapes)))))

(define on-right (cλ on 'right))
(define on-left (cλ on 'left))
(define on-back (cλ on 'back))
(define on-front (cλ on 'front))
(define on-top (cλ on 'top))
(define on-bottom (cλ on 'bottom))

; /on